home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / rbtest.scm < prev    next >
Encoding:
Text File  |  1994-05-27  |  2.1 KB  |  60 lines
  1. ;;; "rbtest.scm" Test rbtree.scm    -*-Scheme-*-
  2. ;;;; Copyright (C) 1990 Patrick G. Solbavarro.
  3.  
  4. (require 'red-black-tree)
  5. (require 'format)
  6.  
  7. ;;;; For debugging.  LEFT-THUNK called with no args before descending left;
  8. ;;;; RIGHT-THUNK with no args after ascending right.
  9. (define (rb-tree-in-order-walk tree left-thunk node-thunk right-thunk)
  10.   (define (rb-node-in-order-walk node left-thunk node-thunk right-thunk)
  11.     (if (not node)
  12.     #f
  13.     (begin (left-thunk)
  14.            (rb-node-in-order-walk
  15.         (rb-node-left node) left-thunk node-thunk right-thunk)
  16.            (node-thunk node)
  17.            (rb-node-in-order-walk
  18.         (rb-node-right node) left-thunk node-thunk right-thunk)
  19.            (right-thunk))))
  20.   (rb-node-in-order-walk (rb-tree-root tree) left-thunk node-thunk right-thunk))
  21.  
  22. (define (show-rb-tree tree)
  23.   (rb-tree-in-order-walk
  24.    tree
  25.    (lambda () (format #t "["))
  26.    (lambda (node) (format #t "<~s ~s>" (rb-node-data node) (rb-node-color node)))
  27.    (lambda () (format #t "]")))
  28.   (format #t "~%"))
  29.  
  30. ;;; if Scheme had RANDOM, I'd use that
  31. (define (build-test-tree)
  32.   (let ((new-tree (make-rb-tree #f #f #f #f <)))
  33.     (let ((contents '(61 65 66 13 50 43 77 93 91 8 59 76 94 38 20 64 5 37 51
  34.              23)))
  35.       (do ((contents-tail contents (cdr contents-tail)))
  36.       ((null? contents-tail))
  37.     (rb-insert! new-tree (make-rb-node (car contents-tail)))))
  38.     new-tree))
  39.  
  40. (define (flush-test-tree tree)
  41.   (define (rb-tree-nth tree n)
  42.     (define (rb-node-nth node n)
  43.       (if (= n 0)
  44.       node
  45.       (rb-node-nth (rb-node-successor node) (- n 1))))
  46.     (rb-node-nth (rb-tree-minimum tree) n))
  47.   ;; removal indices crafted so that never remove elt beyond remaining elts
  48.   (let ((removal-indices '(12 1 7 3 0 7 10 11 3 8 6 4 5 2 4 1 0 0 1 0)))
  49.     ;; show tree
  50.     (show-rb-tree tree)
  51.     ;; now remove items
  52.     (do ((removal-indices-tail removal-indices (cdr removal-indices-tail)))
  53.     ((null? removal-indices-tail))
  54.       (let ((node-to-delete (rb-tree-nth tree (car removal-indices-tail))))
  55.     (format #t "Deleting node with datum ~S~%" (rb-node-data node-to-delete))
  56.     (rb-delete! tree node-to-delete))
  57.       (show-rb-tree tree))))
  58.  
  59. (flush-test-tree (build-test-tree))
  60.